home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Dylan Related / Mindy-1.1 (sources only) / mindy-1.1 / interp / func.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-16  |  50.1 KB  |  1,880 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: func.c,v 1.30 94/07/12 00:41:58 rgs Exp $
  27. *
  28. * This file implements functions.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include <stdio.h>
  33.  
  34. #include "mindy.h"
  35. #include "gc.h"
  36. #include "thread.h"
  37. #include "bool.h"
  38. #include "list.h"
  39. #include "num.h"
  40. #include "class.h"
  41. #include "obj.h"
  42. #include "sym.h"
  43. #include "interp.h"
  44. #include "vec.h"
  45. #include "type.h"
  46. #include "module.h"
  47. #include "print.h"
  48. #include "driver.h"
  49. #include "error.h"
  50. #include "def.h"
  51. #include "func.h"
  52.  
  53. obj_t obj_FunctionClass = NULL;
  54. static obj_t obj_RawFunctionClass = NULL;
  55. obj_t obj_MethodClass = NULL;
  56. obj_t obj_ByteMethodClass = NULL;
  57. static obj_t obj_RawMethodClass;
  58. static obj_t obj_BuiltinMethodClass = NULL;
  59. static obj_t obj_AccessorMethodClass = NULL;
  60. obj_t obj_GFClass = NULL;
  61. obj_t obj_MethodInfoClass = NULL;
  62. static obj_t obj_GFCacheClass = NULL;
  63.  
  64.  
  65. /* Tracing support. */
  66.  
  67. boolean Tracing = FALSE;
  68.  
  69. static void trace_call(obj_t function, obj_t *args, int nargs)
  70. {
  71.     printf("> 0x%08lx: ", (unsigned long)(args-1));
  72.     prin1(function_debug_name_or_self(function));
  73.     printf("(");
  74.     if (nargs > 0) {
  75.     prin1(*args++);
  76.     while (--nargs > 0) {
  77.         printf(", ");
  78.         prin1(*args++);
  79.     }
  80.     }
  81.     printf(")\n");
  82. }
  83.  
  84. static void trace_return(obj_t *old_sp, obj_t *vals, int nvals)
  85. {
  86.     printf("< 0x%08lx: ", (unsigned long)old_sp);
  87.     if (nvals > 0) {
  88.     prin1(*vals++);
  89.     while (--nvals > 0) {
  90.         printf(", ");
  91.         prin1(*vals++);
  92.     }
  93.     }
  94.     printf("\n");
  95. }
  96.  
  97.  
  98. /* Functions in general. */
  99.  
  100. struct gf_cache {
  101.     obj_t class;
  102.     boolean simple;
  103.     obj_t cached_result;
  104.     int size;
  105.     obj_t cached_classes[0];
  106. };
  107.  
  108. obj_t make_gf_cache(int req_args, obj_t cached_result)
  109. {
  110.     obj_t res = alloc(obj_GFCacheClass, (sizeof(struct gf_cache) +
  111.                      req_args * sizeof(obj_t)));
  112.     struct gf_cache *gfc = obj_ptr(struct gf_cache *, res);
  113.     int i;
  114.  
  115.     gfc->simple = TRUE;
  116.     gfc->cached_result = cached_result;
  117.     gfc->size = req_args;
  118.     for (i = 0; i < req_args; i++)
  119.     gfc->cached_classes[i] = obj_Nil;
  120.  
  121.     return res;
  122. }
  123.  
  124. struct function {
  125.     obj_t class;
  126.     void (*xep)(struct thread *thread, int nargs);
  127.     obj_t debug_name;
  128.     int required_args;
  129.     boolean restp;
  130.     obj_t keywords;
  131.     boolean all_keys;
  132.     obj_t result_types;
  133.     obj_t more_results_type;
  134. };
  135.  
  136. #define FUNC(o) obj_ptr(struct function *, o)
  137.  
  138. obj_t make_raw_function(char *debug_name, int required_args,
  139.             boolean restp, obj_t keywords, boolean all_keys,
  140.             obj_t result_types, obj_t more_results_type,
  141.             void xep(struct thread *thread, int nargs))
  142. {
  143.     obj_t res = alloc(obj_RawFunctionClass, sizeof(struct function));
  144.  
  145.     FUNC(res)->xep = xep;
  146.     FUNC(res)->debug_name = symbol(debug_name);
  147.     FUNC(res)->required_args = required_args;
  148.     FUNC(res)->restp = restp;
  149.     FUNC(res)->keywords = keywords;
  150.     FUNC(res)->all_keys = all_keys;
  151.     FUNC(res)->result_types = result_types;
  152.     FUNC(res)->more_results_type = more_results_type;
  153.  
  154.     return res;
  155. }
  156.  
  157. obj_t function_debug_name(obj_t function)
  158. {
  159.     return FUNC(function)->debug_name;
  160. }
  161.  
  162. obj_t function_debug_name_or_self(obj_t function)
  163. {
  164.     if (instancep(function, obj_FunctionClass)) {
  165.     obj_t debug_name = FUNC(function)->debug_name;
  166.  
  167.     if (debug_name == obj_False)
  168.         return function;
  169.     else
  170.         return debug_name;
  171.     }
  172.     else
  173.     return function;
  174. }
  175.  
  176. void invoke(struct thread *thread, int nargs)
  177. {
  178.     obj_t function = thread->sp[-nargs-1];
  179.     int required = FUNC(function)->required_args;
  180.     obj_t func_type = object_class(function);
  181.  
  182.     if (func_type != obj_BuiltinMethodClass
  183.     && func_type != obj_ByteMethodClass
  184.     && func_type != obj_BuiltinMethodClass
  185.     && func_type != obj_GFClass
  186.     && !subtypep(func_type, obj_FunctionClass))
  187.     lose("invoke called on a non-function.");
  188.  
  189.     if (Tracing)
  190.     trace_call(function, thread->sp - nargs, nargs);
  191.  
  192.     if (nargs < required) {
  193.     push_linkage(thread, thread->sp - nargs);
  194.     error("Too few arguments for %=: expected %d, got %d",
  195.           function_debug_name_or_self(function),
  196.           make_fixnum(required),
  197.           make_fixnum(nargs));
  198.     }
  199.     
  200.     if (!FUNC(function)->restp && FUNC(function)->keywords == obj_False
  201.       && nargs > required) {
  202.     push_linkage(thread, thread->sp - nargs);
  203.     error("Too many arguments for %=: expected %d, got %d",
  204.           function_debug_name_or_self(function),
  205.           make_fixnum(required),
  206.           make_fixnum(nargs));
  207.     }
  208.  
  209.     FUNC(function)->xep(thread, nargs);
  210. #if !SLOW_LONGJMP
  211.     go_on();
  212. #endif
  213. }
  214.  
  215. obj_t *push_linkage(struct thread *thread, obj_t *args)
  216. {
  217.     obj_t *fp = thread->sp += 4;
  218.  
  219.     fp[-4] = rawptr_obj(thread->fp);
  220.     fp[-3] = rawptr_obj(args-1);
  221.     fp[-2] = thread->component;
  222.     fp[-1] = make_fixnum(thread->pc);
  223.     thread->fp = fp;
  224.     thread->component = rawptr_obj(NULL);
  225.     thread->pc = 0;
  226.  
  227.     return fp;
  228. }
  229.  
  230. obj_t *pop_linkage(struct thread *thread)
  231. {
  232.     obj_t *fp = thread->fp;
  233.  
  234.     thread->fp = obj_rawptr(fp[-4]);
  235.     thread->component = fp[-2];
  236.     thread->pc = fixnum_value(fp[-1]);
  237.  
  238.     return obj_rawptr(fp[-3]);
  239. }
  240.  
  241. void set_c_continuation(struct thread *thread,
  242.             void cont(struct thread *thread, obj_t *vals))
  243. {
  244.     thread->component = rawptr_obj(cont);
  245.     thread->pc = 0;
  246. }
  247.  
  248. #if SLOW_LONGJMP
  249. void do_return(struct thread *thread, obj_t *old_sp, obj_t *vals)
  250. #else
  251. void do_return_setup(struct thread *thread, obj_t *old_sp, obj_t *vals)
  252. #endif
  253. {
  254.     if (Tracing)
  255.     trace_return(old_sp, vals, thread->sp - vals);
  256.  
  257.     if (thread->pc)
  258.     do_byte_return(thread, old_sp, vals);
  259.     else {
  260.     void (*cont)(struct thread *thread, obj_t *vals)
  261.         = (void (*)(struct thread *thread, obj_t *vals))
  262.         obj_rawptr(thread->component);
  263.     if (cont) {
  264.         thread->component = rawptr_obj(NULL);
  265.         if (old_sp != vals) {
  266.         obj_t *src = vals, *dst = old_sp, *end = thread->sp;
  267.         while (src < end)
  268.             *dst++ = *src++;
  269.         thread->sp = dst;
  270.         }
  271.         (*cont)(thread, old_sp);
  272.     }
  273.     else
  274.         lose("Attempt to return, but no continuation established.\n");
  275.     }
  276. }
  277.  
  278. #if !SLOW_LONGJMP
  279. void do_return(struct thread *thread, obj_t *old_sp, obj_t *vals)
  280. {
  281.     do_return_setup(thread, old_sp, vals);
  282.     go_on();
  283. }
  284. #endif
  285.  
  286.  
  287. /* Methods */
  288.  
  289. struct method {
  290.     obj_t class;
  291.     void (*xep)(struct thread *thread, int nargs);
  292.     obj_t debug_name;
  293.     int required_args;
  294.     boolean restp;
  295.     obj_t keywords;
  296.     boolean all_keys;
  297.     obj_t result_types;
  298.     obj_t more_results_type;
  299.     obj_t specializers;
  300.     obj_t class_cache;            /* #F or a gf_cache */
  301.     void (*iep)(obj_t self, struct thread *thread, obj_t *args);
  302. };
  303.  
  304. #define METHOD(o) obj_ptr(struct method *, o)
  305.  
  306. static obj_t *push_keywords(obj_t *sp, obj_t keywords, obj_t *args, int nargs)
  307. {
  308.     while (keywords != obj_Nil) {
  309.     obj_t key_info = HEAD(keywords);
  310.     obj_t key = HEAD(key_info);
  311.     int i;
  312.  
  313.     for (i = 0; i < nargs; i += 2) {
  314.         if (key == args[i]) {
  315.         *sp++ = args[i+1];
  316.         goto next;
  317.         }
  318.     }
  319.     *sp++ = TAIL(key_info);
  320.  
  321.       next:
  322.     keywords = TAIL(keywords);
  323.     }
  324.     return sp;
  325. }
  326.  
  327. static void really_invoke_methods(obj_t method, obj_t next_methods,
  328.                   struct thread *thread, int nargs)
  329. {
  330.     obj_t *args = thread->sp - nargs;
  331.     boolean restp = METHOD(method)->restp;
  332.     obj_t keywords = METHOD(method)->keywords;
  333.     int req_args = METHOD(method)->required_args;
  334.     int rest_count = nargs - req_args;
  335.  
  336.     /* Change the function on the stack to be the next method so that */
  337.     /* backtraces look better. */
  338.     args[-1] = method;
  339.  
  340.     if (restp || keywords != obj_False) {
  341.     obj_t *ptr = thread->sp - rest_count;
  342.     obj_t rest = make_vector(rest_count, ptr);
  343.  
  344.     if (restp)
  345.         *ptr++ = rest;
  346.  
  347.     if (keywords != obj_False) {
  348.         if ((rest_count & 1) != 0) {
  349.         push_linkage(thread, args);
  350.         error("Odd number of keyword/value arguments.");
  351.         }
  352.  
  353.         ptr = push_keywords(ptr, keywords, SOVEC(rest)->contents,
  354.                 rest_count);
  355.     }
  356.  
  357.     thread->sp = ptr;
  358.     }
  359.  
  360.     /* add next-method info. */
  361.     *thread->sp++ = next_methods;
  362.  
  363.     METHOD(method)->iep(method, thread, args);
  364. }
  365.  
  366. void invoke_methods(obj_t method, obj_t next_methods,
  367.             struct thread *thread, int nargs)
  368. {
  369.     if (method == obj_False) {
  370.     push_linkage(thread, thread->sp - nargs);
  371.     error("It is ambiguous which of these methods to invoke:\n  %=",
  372.           next_methods);
  373.     }
  374.     else
  375.     really_invoke_methods(method, next_methods, thread, nargs);
  376. }
  377.  
  378. /* Version of applicable_method_p which does extra work to allow SAM caching 
  379.    for generic function dispatch.  The "cache" argument is carried across
  380.    several calls to gfd_applicable_method_p and may be modified to reflect a
  381.    more restrictive set of types. */
  382. static boolean
  383.     gfd_applicable_method_p(obj_t method, obj_t *args, obj_t cache)
  384. {
  385.     obj_t specializers = METHOD(method)->specializers;
  386.     obj_t *cached_classes = obj_ptr(struct gf_cache *, cache)->cached_classes;
  387.  
  388.     while (specializers != obj_Nil) {
  389.     obj_t arg = *args++;
  390.     obj_t arg_class = *cached_classes++;
  391.     obj_t specializer = HEAD(specializers);
  392.  
  393.     /* arg_class may be either a singleton, a limited_int, or a class.
  394.        This stuff has been worked out on a case by case basis.  It could
  395.        certainly be made clearer, but this could potentially reduce
  396.        the efficiency by a large margin. */
  397.     if (!subtypep(arg_class, specializer))
  398.         if (instancep(arg, specializer)) {
  399.         if (obj_ptr(struct type *, specializer)->type_id == id_LimInt)
  400.             *(cached_classes - 1) =
  401.             (obj_ptr(struct type *,arg_class)->type_id == id_LimInt
  402.              ? intersect_limited_integers(arg_class,specializer)
  403.              : specializer);
  404.         else
  405.             *(cached_classes - 1) = singleton(arg);
  406.         obj_ptr(struct gf_cache *, cache)->simple = FALSE;
  407.         } else {
  408.         if (overlapp(arg_class, specializer)) {
  409.             if (obj_ptr(struct type *,
  410.                 specializer)->type_id == id_LimInt)
  411.             *(cached_classes - 1) =
  412.                 restrict_limited_integers(arg, arg_class,
  413.                               specializer);
  414.             else
  415.             *(cached_classes - 1) = restrict_type(specializer,
  416.                                   arg_class);
  417.             obj_ptr(struct gf_cache *, cache)->simple = FALSE;
  418.         }
  419.         return FALSE;
  420.         }
  421.     specializers = TAIL(specializers);
  422.     }
  423.     return TRUE;
  424. }
  425.  
  426. static boolean applicable_method_p(obj_t method, obj_t *args)
  427. {
  428.     obj_t cache = METHOD(method)->class_cache;
  429.     int max = METHOD(method)->required_args;
  430.     int i;
  431.     obj_t cache_elem, *cache_class, *arg;
  432.     boolean result;
  433.  
  434.     if (cache != obj_False) {
  435.     boolean found = TRUE;
  436.     struct gf_cache *c = obj_ptr(struct gf_cache *, cache);
  437.     register boolean simple = c->simple;
  438.  
  439.     cache_class = c->cached_classes;
  440.     arg = args;
  441.  
  442.     for (i = 0; i < max; i++, arg++, cache_class++) {
  443.         boolean simple_arg = simple ||
  444.         obj_ptr(struct type *, *cache_class)->type_id == id_Class;
  445.         if (simple_arg ? *cache_class != object_class(*arg)
  446.                    : !instancep(*arg, *cache_class)) {
  447.         found = FALSE;
  448.         break;
  449.         }
  450.     }
  451.     if (found)
  452.         return TRUE;
  453.     }
  454.  
  455.     /* It wasn't in the cache.... */
  456.     cache_elem = (cache == obj_False) ? make_gf_cache(max, obj_False) : cache;
  457.     cache_class = obj_ptr(struct gf_cache *, cache_elem)->cached_classes;
  458.     arg = args;
  459.  
  460.     for (i = 0; i < max; i++, arg++, cache_class++)
  461.     *cache_class = object_class(*arg);
  462.  
  463.     result = gfd_applicable_method_p(method, args, cache_elem);
  464.     METHOD(method)->class_cache = cache_elem;
  465.     return result;
  466. }
  467.  
  468. static boolean method_accepts_keyword(obj_t method, obj_t keyword)
  469. {
  470.     obj_t keywords = METHOD(method)->keywords;
  471.  
  472.     assert(!METHOD(method)->all_keys);
  473.     assert(keywords != obj_False);
  474.  
  475.     while (keywords != obj_Nil) {
  476.     if (HEAD(HEAD(keywords)) == keyword)
  477.         return TRUE;
  478.     keywords = TAIL(keywords);
  479.     }
  480.     return FALSE;
  481. }
  482.  
  483. static void method_xep(struct thread *thread, int nargs)
  484. {
  485.     obj_t *args = thread->sp - nargs;
  486.     obj_t method = args[-1];
  487.  
  488.     if (applicable_method_p(method, args)) {
  489.     if (METHOD(method)->keywords != obj_False
  490.           && !METHOD(method)->all_keys) {
  491.         obj_t *ptr = args+METHOD(method)->required_args;
  492.         while (ptr < thread->sp) {
  493.         if (!method_accepts_keyword(method, *ptr)) {
  494.             push_linkage(thread, args);
  495.             error("Method %= does not accept the keyword %=",
  496.               function_debug_name_or_self(method), *ptr);
  497.         }
  498.         ptr += 2;
  499.         }
  500.     }
  501.     invoke_methods(method, obj_Nil, thread, nargs);
  502.     }
  503.     else {
  504.     push_linkage(thread, args);
  505.     error("Method %= is not applicable when given the arguments %=",
  506.           function_debug_name_or_self(method),
  507.           make_vector(nargs, args));
  508.     }
  509. }
  510.  
  511. obj_t make_raw_method(char *debug_name, obj_t specializers, boolean restp,
  512.               obj_t keywords, boolean all_keys, obj_t result_types,
  513.               obj_t more_results_type,
  514.               void iep(obj_t self, struct thread *thread, obj_t *args))
  515. {
  516.     obj_t res = alloc(obj_RawMethodClass, sizeof(struct method));
  517.  
  518.     METHOD(res)->xep = method_xep;
  519.     METHOD(res)->debug_name = symbol(debug_name);
  520.     METHOD(res)->required_args = length(specializers);
  521.     METHOD(res)->restp = restp;
  522.     METHOD(res)->keywords = keywords;
  523.     METHOD(res)->all_keys = all_keys;
  524.     METHOD(res)->result_types = result_types;
  525.     METHOD(res)->more_results_type = more_results_type;
  526.     METHOD(res)->specializers = specializers;
  527.     METHOD(res)->class_cache = obj_False;
  528.     METHOD(res)->iep = iep;
  529.  
  530.     return res;
  531. }
  532.  
  533. void set_method_iep(obj_t method, 
  534.             void iep(obj_t self, struct thread *thread, obj_t *args))
  535. {
  536.     METHOD(method)->iep = iep;
  537. }
  538.  
  539. static boolean same_specializers(obj_t specializers1, obj_t specializers2)
  540. {
  541.     obj_t scan1 = specializers1;
  542.     obj_t scan2 = specializers2;
  543.  
  544.     while (scan1 != obj_Nil) {
  545.     obj_t spec1 = HEAD(scan1);
  546.     obj_t spec2 = HEAD(scan2);
  547.  
  548.     if (!subtypep(spec1, spec2) || !subtypep(spec2, spec1))
  549.         return FALSE;
  550.  
  551.     scan1 = TAIL(scan1);
  552.     scan2 = TAIL(scan2);
  553.     }
  554.     return TRUE;
  555. }
  556.  
  557. enum method_comparison {
  558.     method_MoreSpecific, method_LessSpecific,
  559.     method_Identical, method_Ambiguous
  560. };
  561.  
  562. static enum method_comparison compare_methods(obj_t meth1, obj_t meth2,
  563.                           obj_t *args)
  564. {
  565.     boolean meth1_first = FALSE;
  566.     boolean meth2_first = FALSE;
  567.     obj_t scan1 = METHOD(meth1)->specializers;
  568.     obj_t scan2 = METHOD(meth2)->specializers;
  569.  
  570.     while (scan1 != obj_Nil) {
  571.     obj_t spec1 = HEAD(scan1);
  572.     obj_t spec2 = HEAD(scan2);
  573.     boolean spec1_more_specific = subtypep(spec1, spec2);
  574.     boolean spec2_more_specific = subtypep(spec2, spec1);
  575.  
  576.     if (spec1_more_specific && spec2_more_specific)
  577.         /* The two specializers are identical. */
  578.         ;
  579.     else if (spec1_more_specific) {
  580.         if (meth2_first)
  581.         return method_Ambiguous;
  582.         meth1_first = TRUE;
  583.     }
  584.     else if (spec2_more_specific) {
  585.         if (meth1_first)
  586.         return method_Ambiguous;
  587.         meth2_first = TRUE;
  588.     }
  589.     else if (instancep(spec1, obj_ClassClass)
  590.          && instancep(spec2, obj_ClassClass)) {
  591.         obj_t class = object_class(*args);
  592.         obj_t cpl = obj_ptr(struct class *, class)->cpl;
  593.  
  594.         while (cpl != obj_Nil) {
  595.         obj_t super = HEAD(cpl);
  596.         if (super == spec1) {
  597.             if (meth2_first)
  598.             return method_Ambiguous;
  599.             meth1_first = TRUE;
  600.             break;
  601.         }
  602.         if (super == spec2) {
  603.             if (meth1_first)
  604.             return method_Ambiguous;
  605.             meth2_first = TRUE;
  606.             break;
  607.         }
  608.         cpl = TAIL(cpl);
  609.         }
  610.         if (cpl == obj_Nil)
  611.         lose("Couldn't find either class in the objects cpl?");
  612.     }
  613.     else
  614.         return method_Ambiguous;
  615.  
  616.     scan1 = TAIL(scan1);
  617.     scan2 = TAIL(scan2);
  618.     args++;
  619.     }
  620.  
  621.     if (meth1_first)
  622.     return method_MoreSpecific;
  623.     else if (meth2_first)
  624.     return method_LessSpecific;
  625.     else
  626.     return method_Identical;
  627. }
  628.  
  629.  
  630. /* builtin methods. */
  631.  
  632. struct builtin_method {
  633.     obj_t class;
  634.     void (*xep)(struct thread *thread, int nargs);
  635.     obj_t debug_name;
  636.     int required_args;
  637.     boolean restp;
  638.     obj_t keywords;
  639.     boolean all_keys;
  640.     obj_t result_types;
  641.     obj_t more_results_type;
  642.     obj_t specializers;
  643.     obj_t class_cache;            /* #F or a gf_cache */
  644.     void (*iep)(obj_t self, struct thread *thread, obj_t *args);
  645.     obj_t (*func)();
  646. };
  647.  
  648. #define BUILTIN_METHOD(o) obj_ptr(struct builtin_method *, o)
  649.  
  650. static void builtin_method_iep_1_arg(obj_t method, struct thread *thread,
  651.                      obj_t *args)
  652. {
  653.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  654.     obj_t *old_sp;
  655.     obj_t value;
  656.  
  657.     push_linkage(thread, args);
  658.  
  659.     value = func(args[0]);
  660.  
  661.     old_sp = pop_linkage(thread);
  662.     *old_sp = value;
  663.     thread->sp = old_sp+1;
  664.  
  665.     do_return(thread, old_sp, old_sp);
  666. }
  667.  
  668. static void builtin_method_iep_2_args(obj_t method, struct thread *thread,
  669.                       obj_t *args)
  670. {
  671.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  672.     obj_t *old_sp;
  673.     obj_t value;
  674.  
  675.     push_linkage(thread, args);
  676.  
  677.     value = func(args[0], args[1]);
  678.  
  679.     old_sp = pop_linkage(thread);
  680.     *old_sp = value;
  681.     thread->sp = old_sp+1;
  682.  
  683.     do_return(thread, old_sp, old_sp);
  684. }
  685.  
  686. static void builtin_method_iep_3_args(obj_t method, struct thread *thread,
  687.                       obj_t *args)
  688. {
  689.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  690.     obj_t *old_sp;
  691.     obj_t value;
  692.  
  693.     push_linkage(thread, args);
  694.  
  695.     value = func(args[0], args[1], args[2]);
  696.  
  697.     old_sp = pop_linkage(thread);
  698.     *old_sp = value;
  699.     thread->sp = old_sp+1;
  700.  
  701.     do_return(thread, old_sp, old_sp);
  702. }
  703.  
  704. static void builtin_method_iep_4_args(obj_t method, struct thread *thread,
  705.                       obj_t *args)
  706. {
  707.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  708.     obj_t *old_sp;
  709.     obj_t value;
  710.  
  711.     push_linkage(thread, args);
  712.  
  713.     value = func(args[0], args[1], args[2], args[3]);
  714.  
  715.     old_sp = pop_linkage(thread);
  716.     *old_sp = value;
  717.     thread->sp = old_sp+1;
  718.  
  719.     do_return(thread, old_sp, old_sp);
  720. }
  721.  
  722. static void builtin_method_iep_5_args(obj_t method, struct thread *thread,
  723.                       obj_t *args)
  724. {
  725.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  726.     obj_t *old_sp;
  727.     obj_t value;
  728.  
  729.     push_linkage(thread, args);
  730.  
  731.     value = func(args[0], args[1], args[2], args[3], args[4]);
  732.  
  733.     old_sp = pop_linkage(thread);
  734.     *old_sp = value;
  735.     thread->sp = old_sp+1;
  736.  
  737.     do_return(thread, old_sp, old_sp);
  738. }
  739.  
  740. static void builtin_method_iep_6_args(obj_t method, struct thread *thread,
  741.                       obj_t *args)
  742. {
  743.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  744.     obj_t *old_sp;
  745.     obj_t value;
  746.  
  747.     push_linkage(thread, args);
  748.  
  749.     value = func(args[0], args[1], args[2], args[3], args[4], args[5]);
  750.  
  751.     old_sp = pop_linkage(thread);
  752.     *old_sp = value;
  753.     thread->sp = old_sp+1;
  754.  
  755.     do_return(thread, old_sp, old_sp);
  756. }
  757.  
  758. static void builtin_method_iep_7_args(obj_t method, struct thread *thread,
  759.                       obj_t *args)
  760. {
  761.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  762.     obj_t *old_sp;
  763.     obj_t value;
  764.  
  765.     push_linkage(thread, args);
  766.  
  767.     value = func(args[0], args[1], args[2], args[3],
  768.          args[4], args[5], args[6]);
  769.  
  770.     old_sp = pop_linkage(thread);
  771.     *old_sp = value;
  772.     thread->sp = old_sp+1;
  773.  
  774.     do_return(thread, old_sp, old_sp);
  775. }
  776.  
  777. static void builtin_method_iep_8_args(obj_t method, struct thread *thread,
  778.                       obj_t *args)
  779. {
  780.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  781.     obj_t *old_sp;
  782.     obj_t value;
  783.  
  784.     push_linkage(thread, args);
  785.  
  786.     value = func(args[0], args[1], args[2], args[3],
  787.          args[4], args[5], args[6], args[7]);
  788.  
  789.     old_sp = pop_linkage(thread);
  790.     *old_sp = value;
  791.     thread->sp = old_sp+1;
  792.  
  793.     do_return(thread, old_sp, old_sp);
  794. }
  795.  
  796. static void builtin_method_iep_9_args(obj_t method, struct thread *thread,
  797.                       obj_t *args)
  798. {
  799.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  800.     obj_t *old_sp;
  801.     obj_t value;
  802.  
  803.     push_linkage(thread, args);
  804.  
  805.     value = func(args[0], args[1], args[2], args[3], args[4],
  806.          args[5], args[6], args[7], args[8]);
  807.  
  808.     old_sp = pop_linkage(thread);
  809.     *old_sp = value;
  810.     thread->sp = old_sp+1;
  811.  
  812.     do_return(thread, old_sp, old_sp);
  813. }
  814.  
  815. static void builtin_method_iep_10_args(obj_t method, struct thread *thread,
  816.                        obj_t *args)
  817. {
  818.     obj_t (*func)() = BUILTIN_METHOD(method)->func;
  819.     obj_t *old_sp;
  820.     obj_t value;
  821.  
  822.     push_linkage(thread, args);
  823.  
  824.     value = func(args[0], args[1], args[2], args[3], args[4],
  825.          args[5], args[6], args[7], args[8], args[9]);
  826.  
  827.     old_sp = pop_linkage(thread);
  828.     *old_sp = value;
  829.     thread->sp = old_sp+1;
  830.  
  831.     do_return(thread, old_sp, old_sp);
  832. }
  833.  
  834. static void (*builtin_method_ieps[])(obj_t m, struct thread *t, obj_t *a) = {
  835.     NULL,
  836.     builtin_method_iep_1_arg,
  837.     builtin_method_iep_2_args,
  838.     builtin_method_iep_3_args,
  839.     builtin_method_iep_4_args,
  840.     builtin_method_iep_5_args,
  841.     builtin_method_iep_6_args,
  842.     builtin_method_iep_7_args,
  843.     builtin_method_iep_8_args,
  844.     builtin_method_iep_9_args,
  845.     builtin_method_iep_10_args
  846. };
  847.  
  848. #define MAX_BUILTIN_METHOD_ARGS (sizeof(builtin_method_ieps)/sizeof(builtin_method_ieps[0]))
  849.  
  850. obj_t make_builtin_method(char *debug_name, obj_t specializers,
  851.               boolean restp, obj_t keywords, boolean all_keys,
  852.               obj_t result_type, obj_t (*func)())
  853. {
  854.     obj_t res = alloc(obj_BuiltinMethodClass, sizeof(struct builtin_method));
  855.     int req_args = length(specializers);
  856.     int num_args = req_args + 1; /* Add one for the next methods */
  857.  
  858.     if (restp)
  859.     num_args++;
  860.     if (keywords != obj_False)
  861.     num_args += length(keywords);
  862.  
  863.     if (num_args >= MAX_BUILTIN_METHOD_ARGS)
  864.     lose("Can't make a builtin method that wants %d args -- %d at most.",
  865.          num_args, MAX_BUILTIN_METHOD_ARGS-1);
  866.  
  867.     BUILTIN_METHOD(res)->xep = method_xep;
  868.     BUILTIN_METHOD(res)->debug_name = symbol(debug_name);
  869.     BUILTIN_METHOD(res)->required_args = req_args;
  870.     BUILTIN_METHOD(res)->restp = restp;
  871.     BUILTIN_METHOD(res)->keywords = keywords;
  872.     BUILTIN_METHOD(res)->all_keys = all_keys;
  873.     BUILTIN_METHOD(res)->result_types = list1(result_type);
  874.     BUILTIN_METHOD(res)->more_results_type = obj_False;
  875.     BUILTIN_METHOD(res)->specializers = specializers;
  876.     BUILTIN_METHOD(res)->class_cache = obj_False;
  877.     BUILTIN_METHOD(res)->iep = builtin_method_ieps[num_args];
  878.     BUILTIN_METHOD(res)->func = func;
  879.  
  880.     return res;
  881. }
  882.  
  883.  
  884. /* byte methods */
  885.  
  886. struct byte_method {
  887.     obj_t class;
  888.     void (*xep)(struct thread *thread, int nargs);
  889.     obj_t debug_name;
  890.     int required_args;
  891.     boolean restp;
  892.     obj_t keywords;
  893.     boolean all_keys;
  894.     obj_t result_types;
  895.     obj_t more_results_type;
  896.     obj_t specializers;
  897.     obj_t class_cache;            /* #F or a gf_cache */
  898.     void (*iep)(obj_t self, struct thread *thread, obj_t *args);
  899.     obj_t component;
  900.     int n_closure_vars;
  901.     obj_t lexenv[0];
  902. };
  903.  
  904. #define BYTE_METHOD(o) obj_ptr(struct byte_method *, o)
  905.  
  906. obj_t byte_method_component(obj_t method)
  907. {
  908.     return BYTE_METHOD(method)->component;
  909. }
  910.  
  911. static void byte_method_iep(obj_t method, struct thread *thread, obj_t *args)
  912. {
  913.     int i, count;
  914.     obj_t *fp;
  915.  
  916.     /* push the closure vars */
  917.     count = BYTE_METHOD(method)->n_closure_vars;
  918.     for (i = 0; i < count; i++)
  919.     *thread->sp++ = BYTE_METHOD(method)->lexenv[i];
  920.  
  921.     fp = push_linkage(thread, args);
  922.     set_byte_continuation(thread, BYTE_METHOD(method)->component);
  923. #if !SLOW_LONGJMP
  924.     go_on();
  925. #endif
  926. }
  927.  
  928. obj_t make_method_info(boolean restp, obj_t keys, boolean all_keys,
  929.                obj_t component, int n_closure_vars)
  930. {
  931.     obj_t res = alloc(obj_MethodInfoClass, sizeof(struct method_info));
  932.  
  933.     METHOD_INFO(res)->restp = restp;
  934.     METHOD_INFO(res)->keys = keys;
  935.     METHOD_INFO(res)->all_keys = all_keys;
  936.     METHOD_INFO(res)->component = component;
  937.     METHOD_INFO(res)->n_closure_vars = n_closure_vars;
  938.  
  939.     return res;
  940. }
  941.  
  942. obj_t make_byte_method(obj_t method_info, obj_t specializers,
  943.                obj_t result_types, obj_t more_results_type,
  944.                obj_t *lexenv)
  945.                
  946. {
  947.     int n_closure_vars = METHOD_INFO(method_info)->n_closure_vars;
  948.     obj_t res = alloc(obj_ByteMethodClass,
  949.               sizeof(struct byte_method)+sizeof(obj_t)*n_closure_vars);
  950.     obj_t component = METHOD_INFO(method_info)->component;
  951.     int i;
  952.  
  953.     BYTE_METHOD(res)->xep = method_xep;
  954.     BYTE_METHOD(res)->debug_name = COMPONENT(component)->debug_name;
  955.     BYTE_METHOD(res)->required_args = length(specializers);
  956.     BYTE_METHOD(res)->restp = METHOD_INFO(method_info)->restp;
  957.     BYTE_METHOD(res)->keywords = METHOD_INFO(method_info)->keys;
  958.     BYTE_METHOD(res)->all_keys = METHOD_INFO(method_info)->all_keys;
  959.     BYTE_METHOD(res)->result_types = result_types;
  960.     if (more_results_type == obj_True)
  961.     BYTE_METHOD(res)->more_results_type = obj_ObjectClass;
  962.     else
  963.     BYTE_METHOD(res)->more_results_type = more_results_type;
  964.     BYTE_METHOD(res)->specializers = specializers;
  965.     BYTE_METHOD(res)->class_cache = obj_False;
  966.     BYTE_METHOD(res)->iep = byte_method_iep;
  967.     BYTE_METHOD(res)->component = component;
  968.     BYTE_METHOD(res)->n_closure_vars = n_closure_vars;
  969.     for (i = 0; i < n_closure_vars; i++)
  970.     BYTE_METHOD(res)->lexenv[i] = lexenv[i];
  971.  
  972.     return res;
  973. }
  974.  
  975.  
  976. /* Slot accessor methods. */
  977.  
  978. struct accessor_method {
  979.     obj_t class;
  980.     void (*xep)(struct thread *thread, int nargs);
  981.     obj_t debug_name;
  982.     int required_args;
  983.     boolean restp;
  984.     obj_t keywords;
  985.     boolean all_keys;
  986.     obj_t result_types;
  987.     obj_t more_results_type;
  988.     obj_t specializers;
  989.     obj_t class_cache;            /* #F or a gf_cache */
  990.     void (*iep)(obj_t self, struct thread *thread, obj_t *args);
  991.     obj_t datum;
  992. };
  993.  
  994. #define ACCESSOR_METHOD(o) obj_ptr(struct accessor_method *, o)
  995.  
  996. obj_t make_accessor_method(obj_t debug_name, obj_t class, obj_t type,
  997.                boolean setter, obj_t datum,
  998.                void iep(obj_t self, struct thread *thread,
  999.                     obj_t *args))
  1000. {
  1001.     obj_t res = alloc(obj_AccessorMethodClass, sizeof(struct accessor_method));
  1002.  
  1003.     ACCESSOR_METHOD(res)->xep = method_xep;
  1004.     ACCESSOR_METHOD(res)->debug_name = debug_name;
  1005.     ACCESSOR_METHOD(res)->required_args = setter ? 2 : 1;
  1006.     ACCESSOR_METHOD(res)->restp = FALSE;
  1007.     ACCESSOR_METHOD(res)->keywords = obj_False;
  1008.     ACCESSOR_METHOD(res)->all_keys = FALSE;
  1009.     ACCESSOR_METHOD(res)->result_types = list1(type);
  1010.     ACCESSOR_METHOD(res)->more_results_type = obj_False;
  1011.     ACCESSOR_METHOD(res)->specializers
  1012.     = setter ? list2(type, class) : list1(class);
  1013.     ACCESSOR_METHOD(res)->class_cache = obj_False;
  1014.     ACCESSOR_METHOD(res)->iep = iep;
  1015.     ACCESSOR_METHOD(res)->datum = datum;
  1016.  
  1017.     return res;
  1018. }
  1019.  
  1020. obj_t accessor_method_datum(obj_t method)
  1021. {
  1022.     return ACCESSOR_METHOD(method)->datum;
  1023. }
  1024.  
  1025. void set_accessor_method_datum(obj_t method, obj_t datum)
  1026. {
  1027.     ACCESSOR_METHOD(method)->datum = datum;
  1028. }
  1029.  
  1030.  
  1031. /* Generic functions. */
  1032.  
  1033. struct gf {
  1034.     obj_t class;
  1035.     void (*xep)(struct thread *thread, int nargs);
  1036.     obj_t debug_name;
  1037.     int required_args;
  1038.     boolean restp;
  1039.     obj_t keywords;
  1040.     boolean all_keys;
  1041.     obj_t result_types;
  1042.     obj_t more_results_type;
  1043.     obj_t methods;
  1044.     obj_t cache;
  1045. };
  1046.  
  1047. #define GF(o) obj_ptr(struct gf *, o)
  1048.  
  1049. static obj_t
  1050.     slow_sorted_applicable_methods(struct gf *gf, obj_t methods, obj_t *args)
  1051. {
  1052.     obj_t ordered = obj_Nil;
  1053.     obj_t ambiguous = obj_Nil;
  1054.     obj_t scan, *prev;
  1055.     int i, max = gf->required_args;
  1056.     obj_t cache_elem = make_gf_cache(max, obj_False);
  1057.     obj_t *cache = obj_ptr(struct gf_cache *, cache_elem)->cached_classes;
  1058.     obj_t *arg = args;
  1059.     
  1060.     for (i = 0; i < max; i++, arg++, cache++)
  1061.     *cache = object_class(*arg);
  1062.  
  1063.     while (methods != obj_Nil) {
  1064.     obj_t method = HEAD(methods);
  1065.  
  1066.     if (gfd_applicable_method_p(method, args, cache_elem)) {
  1067.         for (prev=&ordered; (scan=*prev) != obj_Nil; prev=&TAIL(scan)) {
  1068.         switch (compare_methods(method, HEAD(scan), args)) {
  1069.           case method_MoreSpecific:
  1070.             *prev = pair(method, scan);
  1071.             goto next;
  1072.           case method_LessSpecific:
  1073.             break;
  1074.           case method_Ambiguous:
  1075.             *prev = obj_Nil;
  1076.             ambiguous = list2(method, HEAD(scan));
  1077.             goto next;
  1078.           case method_Identical:
  1079.             lose("Two identical methods in the same "
  1080.              "generic function?");
  1081.         }
  1082.         }
  1083.         {
  1084.         obj_t new_ambiguous = obj_Nil;
  1085.         boolean more_specific = TRUE;
  1086.  
  1087.         for (scan = ambiguous; scan != obj_Nil; scan = TAIL(scan)) {
  1088.             switch (compare_methods(method, HEAD(scan), args)) {
  1089.               case method_MoreSpecific:
  1090.             break;
  1091.               case method_Ambiguous:
  1092.             new_ambiguous = pair(HEAD(scan), new_ambiguous);
  1093.             break;
  1094.               case method_LessSpecific:
  1095.             more_specific = FALSE;
  1096.             break;
  1097.               case method_Identical:
  1098.             lose("Two identical methods in the same "
  1099.                  "generic function?");
  1100.             }
  1101.         }
  1102.         if (new_ambiguous != obj_Nil)
  1103.             ambiguous = new_ambiguous;
  1104.         else if (more_specific)
  1105.             *prev = list1(method);
  1106.         }
  1107.     }
  1108.       next:
  1109.     methods = TAIL(methods);
  1110.     }
  1111.  
  1112.     if (ambiguous != obj_Nil) {
  1113.     for (prev = &ordered; (scan = *prev) != obj_Nil; prev = &TAIL(scan))
  1114.         ;
  1115.     *prev = pair(obj_False, ambiguous);
  1116.     }
  1117.  
  1118.     obj_ptr(struct gf_cache *, cache_elem)->cached_result = ordered;
  1119.     gf->cache = pair(cache_elem, gf->cache);
  1120.     return ordered;
  1121. }
  1122.  
  1123. static obj_t sorted_applicable_methods(obj_t gf, obj_t *args)
  1124. {
  1125.     struct gf *true_gf = GF(gf);
  1126.     obj_t *prev, cache;
  1127.     obj_t methods = true_gf->methods;
  1128.     int max = true_gf->required_args;
  1129.     
  1130.     /* If there are no methods, then nothing is applicable. */
  1131.     if (methods == obj_Nil)
  1132.     return obj_Nil;
  1133.  
  1134.     for (prev = &true_gf->cache, cache = *prev;
  1135.      cache != obj_Nil; prev = &TAIL(cache), cache = *prev) {
  1136.     struct gf_cache *cache_elem = obj_ptr(struct gf_cache *, HEAD(cache));
  1137.     register boolean simple = cache_elem->simple;
  1138.     obj_t *cache_class = cache_elem->cached_classes;
  1139.     obj_t *arg = args;
  1140.     int i;
  1141.     boolean found = TRUE;
  1142.  
  1143.     for (i = 0; i < max; i++, arg++, cache_class++) {
  1144.         boolean simple_arg = simple ||
  1145.         obj_ptr(struct type *, *cache_class)->type_id == id_Class;
  1146.         if (simple_arg ? *cache_class != object_class(*arg)
  1147.                    : !instancep(*arg, *cache_class)) {
  1148.         found = FALSE;
  1149.         break;
  1150.         }
  1151.     }
  1152.  
  1153.     if (found) {
  1154.         *prev = TAIL(cache);
  1155.         TAIL(cache) = true_gf->cache;
  1156.         true_gf->cache = cache;
  1157.         return cache_elem->cached_result;
  1158.     }
  1159.     }
  1160.  
  1161.     /* We have to do it the slow way */
  1162.     return slow_sorted_applicable_methods(true_gf, methods, args);
  1163. }
  1164.  
  1165. static boolean methods_accept_keyword(obj_t methods, obj_t keyword)
  1166. {
  1167.     obj_t method;
  1168.  
  1169.     while (methods != obj_Nil && (method = HEAD(methods)) != obj_False) {
  1170.     if (method_accepts_keyword(method, keyword))
  1171.         return TRUE;
  1172.     methods = TAIL(methods);
  1173.     }
  1174.     return FALSE;
  1175. }
  1176.  
  1177. static void gf_xep(struct thread *thread, int nargs)
  1178. {
  1179.     obj_t *args = thread->sp - nargs;
  1180.     obj_t gf = args[-1];
  1181.     obj_t methods, primary_method;
  1182.  
  1183.     methods = sorted_applicable_methods(gf, args);
  1184.  
  1185.     if (methods != obj_Nil) {
  1186.     if (GF(gf)->keywords != obj_False && !GF(gf)->all_keys) {
  1187.         obj_t *ptr = args + GF(gf)->required_args;
  1188.         while (ptr < thread->sp) {
  1189.         if (!methods_accept_keyword(methods, *ptr)) {
  1190.             push_linkage(thread, args);
  1191.             error("The keyword %= is accepted by none of the "
  1192.               "applicable methods:\n  %=",
  1193.               *ptr, methods);
  1194.         }
  1195.         ptr += 2;
  1196.         }
  1197.     }
  1198.     primary_method = HEAD(methods);
  1199.     args[-1] = primary_method;
  1200.     invoke_methods(primary_method, TAIL(methods), thread, nargs);
  1201.     }
  1202.     else {
  1203.     push_linkage(thread, args);
  1204.     error("No applicable methods for %= with arguments %=",
  1205.           function_debug_name_or_self(gf),
  1206.           make_vector(nargs, args));
  1207.     }
  1208. }
  1209.  
  1210. obj_t make_generic_function(obj_t debug_name, int req_args, 
  1211.                 boolean restp, obj_t keywords, boolean all_keys,
  1212.                 obj_t result_types, obj_t more_results_type)
  1213. {
  1214.     obj_t res = alloc(obj_GFClass, sizeof(struct gf));
  1215.  
  1216.     GF(res)->xep = gf_xep;
  1217.     GF(res)->debug_name = debug_name;
  1218.     GF(res)->required_args = req_args;
  1219.     GF(res)->restp = restp;
  1220.     GF(res)->keywords = keywords;
  1221.     GF(res)->all_keys = all_keys;
  1222.     GF(res)->result_types = result_types;
  1223.     if (more_results_type == obj_True)
  1224.     GF(res)->more_results_type = obj_ObjectClass;
  1225.     else
  1226.     GF(res)->more_results_type = more_results_type;
  1227.     GF(res)->methods = obj_Nil;
  1228.     GF(res)->cache = obj_Nil;
  1229.  
  1230.     return res;
  1231. }
  1232.  
  1233. obj_t make_default_generic_function(obj_t debug_name, obj_t method)
  1234. {
  1235.     int reqargs = METHOD(method)->required_args;
  1236.     boolean restp = METHOD(method)->restp;
  1237.     obj_t keywords = METHOD(method)->keywords;
  1238.     boolean all_keys = METHOD(method)->all_keys;
  1239.  
  1240.     if (keywords != obj_False)
  1241.     keywords = obj_Nil;
  1242.  
  1243.     return make_generic_function(debug_name, reqargs, restp, keywords,
  1244.                  all_keys, obj_Nil, obj_ObjectClass);
  1245. }
  1246.  
  1247. void set_gf_signature(obj_t gf, int req_args, boolean restp, obj_t keys,
  1248.               boolean all_keys, obj_t result_types,
  1249.               obj_t more_results_type)
  1250. {
  1251.     obj_t methods = GF(gf)->methods;
  1252.  
  1253.     GF(gf)->required_args = req_args;
  1254.     GF(gf)->restp = restp;
  1255.     GF(gf)->keywords = keys;
  1256.     GF(gf)->all_keys = all_keys;
  1257.     GF(gf)->result_types = result_types;
  1258.     if (more_results_type == obj_True)
  1259.     GF(gf)->more_results_type = obj_ObjectClass;
  1260.     else
  1261.     GF(gf)->more_results_type = more_results_type;
  1262.     GF(gf)->methods = obj_Nil;
  1263.  
  1264.     while (methods != obj_Nil) {
  1265.     add_method(gf, HEAD(methods));
  1266.     methods = TAIL(methods);
  1267.     }
  1268. }
  1269.  
  1270. obj_t generic_function_methods(obj_t gf)
  1271. {
  1272.     return GF(gf)->methods;
  1273. }
  1274.  
  1275. obj_t generic_function_keywords(obj_t gf)
  1276. {
  1277.     return GF(gf)->keywords;
  1278. }
  1279.  
  1280. static obj_t really_add_method(obj_t gf, obj_t method)
  1281. {
  1282.     obj_t methods = GF(gf)->methods;
  1283.     obj_t specializers = METHOD(method)->specializers;
  1284.     obj_t scan;
  1285.  
  1286.     GF(gf)->cache = obj_Nil;
  1287.  
  1288.     for (scan = methods; scan != obj_Nil; scan = TAIL(scan)) {
  1289.     obj_t old = HEAD(scan);
  1290.     if (same_specializers(METHOD(old)->specializers, specializers)) {
  1291.         HEAD(scan) = method;
  1292.         return old;
  1293.     }
  1294.     }
  1295.     
  1296.     GF(gf)->methods = pair(method, methods);
  1297.     return obj_False;
  1298. }
  1299.  
  1300. obj_t add_method(obj_t gf, obj_t method)
  1301. {
  1302.     obj_t gfkeys;
  1303.     obj_t gfscan, methscan;
  1304.     int i;
  1305.  
  1306.     if (GF(gf)->required_args != METHOD(method)->required_args)
  1307.     error("%= has %d required arguments, but %= has %d",
  1308.           method, make_fixnum(METHOD(method)->required_args),
  1309.           gf, make_fixnum(GF(gf)->required_args));
  1310.  
  1311.     gfkeys = GF(gf)->keywords;
  1312.     if (gfkeys != obj_False) {
  1313.     /* The generic function takes keyword arguments. */
  1314.     obj_t methkeys = METHOD(method)->keywords;
  1315.  
  1316.     if (methkeys == obj_False)
  1317.         error("%= allows keyword arguments, but %= does not.", gf, method);
  1318.     while (gfkeys != obj_Nil) {
  1319.         obj_t gfkey = HEAD(gfkeys);
  1320.         obj_t scan;
  1321.  
  1322.         for (scan = methkeys; scan != obj_Nil; scan = TAIL(scan))
  1323.         if (HEAD(HEAD(scan)) == gfkey)
  1324.             goto okay;
  1325.         error("The keyword %= is mandatory for %=, "
  1326.           "but %= doesn't accept it.",
  1327.           gfkey, gf, method);
  1328.       okay:
  1329.         gfkeys = TAIL(gfkeys);
  1330.     }
  1331.  
  1332.     if (METHOD(method)->all_keys && !GF(gf)->all_keys)
  1333.         error("%= accepts all keys, but %= does not.", method, gf);
  1334.     }
  1335.     else if (METHOD(method)->keywords != obj_False)
  1336.     error("%= allows keyword arguments, but %= does not.", method, gf);
  1337.     else if (GF(gf)->restp) {
  1338.     if (!METHOD(method)->restp)
  1339.         error("%= accepts a variable number of arguments, "
  1340.           "but %= does not.",
  1341.           gf, method);
  1342.     }
  1343.     else if (METHOD(method)->restp)
  1344.     error("%= accepts a variable number of arguments, but %= does not.",
  1345.           method, gf);
  1346.  
  1347.     gfscan = GF(gf)->result_types;
  1348.     methscan = METHOD(method)->result_types;
  1349.     i = 0;
  1350.     while (gfscan != obj_Nil && methscan != obj_Nil) {
  1351.     obj_t gftype = HEAD(gfscan);
  1352.     obj_t methtype = HEAD(methscan);
  1353.  
  1354.     if (!subtypep(methtype, gftype))
  1355.         error("Result %= is an instance of %= for %=, "
  1356.           "but is an instance of %= for %=",
  1357.           make_fixnum(i), gftype, gf, methtype, method);
  1358.  
  1359.     gfscan = TAIL(gfscan);
  1360.     methscan = TAIL(methscan);
  1361.     i++;
  1362.     }
  1363.  
  1364.     if (gfscan != obj_Nil) {
  1365.     int gf_returns = i;
  1366.     while (gfscan != obj_Nil) {
  1367.         gf_returns++;
  1368.         gfscan = TAIL(gfscan);
  1369.     }
  1370.     if (GF(gf)->more_results_type != obj_False)
  1371.         error("%= returns at least %d results, but %= only returns %d",
  1372.           gf, make_fixnum(gf_returns), method, make_fixnum(i));
  1373.     else
  1374.         error("%= returns exactly %d results, but %= only returns %d",
  1375.           gf, make_fixnum(gf_returns), method, make_fixnum(i));
  1376.     }
  1377.     if (methscan != obj_Nil) {
  1378.     obj_t gftype = GF(gf)->more_results_type;
  1379.  
  1380.     if (gftype == obj_False) {
  1381.         int meth_returns = i;
  1382.         while (methscan != obj_Nil) {
  1383.         methscan = TAIL(methscan);
  1384.         meth_returns++;
  1385.         }
  1386.         if (METHOD(method)->more_results_type != obj_False)
  1387.         error("%= returns exactly %d results, "
  1388.               "but %= returns %d or more",
  1389.               gf, make_fixnum(i), method, make_fixnum(meth_returns));
  1390.         else
  1391.         error("%= returns exactly %d results, but %= returns %d",
  1392.               gf, make_fixnum(i), method, make_fixnum(meth_returns));
  1393.     }
  1394.     while (methscan != obj_Nil) {
  1395.         obj_t methtype = HEAD(methscan);
  1396.  
  1397.         if (!subtypep(methtype, gftype))
  1398.         error("Result %d is an instance of %= for %=, "
  1399.               "but is an instance of %= for %=",
  1400.               make_fixnum(i), gftype, gf, methtype, method);
  1401.  
  1402.         methscan = TAIL(methscan);
  1403.         i++;
  1404.     }
  1405.     }
  1406.  
  1407.     if (METHOD(method)->more_results_type != obj_False)
  1408.     if (GF(gf)->more_results_type != obj_False) {
  1409.         if (!subtypep(METHOD(method)->more_results_type,
  1410.               GF(gf)->more_results_type))
  1411.         error("Results %d and on are instances of %= for %=, "
  1412.               "but are instances of %= for %=",
  1413.               make_fixnum(i), GF(gf)->more_results_type, gf,
  1414.               METHOD(method)->more_results_type, method);
  1415.     }
  1416.     else
  1417.         error("%= returns exactly %d results, but %= returns %d or more",
  1418.           gf, make_fixnum(i), method, make_fixnum(i));
  1419.  
  1420.     return really_add_method(gf, method);
  1421. }
  1422.  
  1423.  
  1424. /* Dylan interface functions. */
  1425.  
  1426. static obj_t dylan_make_gf(obj_t debug_name, obj_t required,
  1427.                obj_t restp, obj_t keywords, obj_t all_keys,
  1428.                obj_t res_types, obj_t more_res_type)
  1429. {
  1430.     return make_generic_function(debug_name, fixnum_value(required),
  1431.                  restp != obj_False, keywords,
  1432.                  all_keys != obj_False, res_types,
  1433.                  more_res_type);
  1434. }
  1435.  
  1436. static void dylan_add_method(obj_t self, struct thread *thread, obj_t *args)
  1437. {
  1438.     obj_t *vals = args-1;
  1439.     obj_t gf = args[0];
  1440.     obj_t method = args[1];
  1441.     obj_t old = add_method(gf, method);
  1442.  
  1443.     thread->sp = vals + 2;
  1444.     vals[0] = method;
  1445.     vals[1] = old;
  1446.  
  1447.     do_return(thread, vals, vals);
  1448. }
  1449.  
  1450. static obj_t method_specializers(obj_t method)
  1451. {
  1452.     return METHOD(method)->specializers;
  1453. }
  1454.  
  1455. static void dylan_function_arguments(obj_t self, struct thread *thread,
  1456.                      obj_t *args)
  1457. {
  1458.     obj_t *vals = args-1;
  1459.     obj_t func = *args;
  1460.     obj_t keywords = FUNC(func)->keywords;
  1461.  
  1462.     thread->sp = vals + 3;
  1463.     vals[0] = make_fixnum(FUNC(func)->required_args);
  1464.     if (FUNC(func)->restp && keywords == obj_False)
  1465.     vals[1] = obj_True;
  1466.     else
  1467.     vals[1] = obj_False;
  1468.     vals[2] = FUNC(func)->all_keys ? symbol("all") : keywords;
  1469.  
  1470.     do_return(thread, vals, vals);
  1471. }
  1472.  
  1473. static void dylan_method_arguments(obj_t self, struct thread *thread,
  1474.                    obj_t *args)
  1475. {
  1476.     obj_t *vals = args-1;
  1477.     obj_t meth = *args;
  1478.     obj_t keywords = METHOD(meth)->keywords;
  1479.  
  1480.     thread->sp = vals + 3;
  1481.     vals[0] = make_fixnum(METHOD(meth)->required_args);
  1482.     if (METHOD(meth)->restp && keywords == obj_False)
  1483.     vals[1] = obj_True;
  1484.     else
  1485.     vals[1] = obj_False;
  1486.     if (METHOD(meth)->all_keys)
  1487.     vals[2] = symbol("all");
  1488.     else if (keywords != obj_False) {
  1489.     obj_t new = obj_Nil;
  1490.     while (keywords != obj_Nil) {
  1491.         new = pair(HEAD(HEAD(keywords)), new);
  1492.         keywords = TAIL(keywords);
  1493.     }
  1494.     vals[2] = new;
  1495.     }
  1496.     else
  1497.     vals[2] = obj_False;
  1498.  
  1499.     do_return(thread, vals, vals);
  1500. }
  1501.  
  1502. static obj_t dylan_sorted_app_meths(obj_t gf, obj_t args)
  1503. {
  1504.     int nargs = SOVEC(args)->length;
  1505.  
  1506.     if (nargs < GF(gf)->required_args)
  1507.     return obj_Nil;
  1508.     else
  1509.     return sorted_applicable_methods(gf, SOVEC(args)->contents);
  1510. }
  1511.  
  1512. static obj_t dylan_app_meth_p(obj_t method, obj_t args)
  1513. {
  1514.     int nargs = SOVEC(args)->length;
  1515.     
  1516.     if (nargs < METHOD(method)->required_args)
  1517.     return obj_False;
  1518.     else if (applicable_method_p(method, SOVEC(args)->contents))
  1519.     return obj_True;
  1520.     else
  1521.     return obj_False;
  1522. }
  1523.  
  1524. static obj_t dylan_find_method(obj_t gf, obj_t specializers)
  1525. {
  1526.     obj_t scan;
  1527.  
  1528.     for (scan = specializers; scan != obj_Nil; scan = TAIL(scan))
  1529.     check_type(HEAD(scan), obj_TypeClass);
  1530.  
  1531.     for (scan = GF(gf)->methods; scan != obj_Nil; scan = TAIL(scan)) {
  1532.     obj_t method = HEAD(scan);
  1533.     if (same_specializers(METHOD(method)->specializers, specializers))
  1534.         return method;
  1535.     }
  1536.  
  1537.     return obj_False;
  1538. }
  1539.  
  1540. static obj_t dylan_remove_method(obj_t gf, obj_t method)
  1541. {
  1542.     obj_t scan, *prev;
  1543.  
  1544.     GF(gf)->cache = obj_Nil;
  1545.  
  1546.     prev = &GF(gf)->methods;
  1547.     while ((scan = *prev) != obj_Nil) {
  1548.     if (method == HEAD(scan)) {
  1549.         *prev = TAIL(scan);
  1550.         return method;
  1551.     }
  1552.     prev = &TAIL(scan);
  1553.     }
  1554.     error("%= isn't one of the methods in %=", method, gf);
  1555.     return NULL;
  1556. }
  1557.  
  1558. static void dylan_do_next_method(obj_t self, struct thread *thread,
  1559.                  obj_t *args)
  1560. {
  1561.     obj_t methods = args[0];
  1562.     obj_t new_args = args[1];
  1563.     int len = SOVEC(new_args)->length;
  1564.     int i;
  1565.  
  1566.     for (i = 0; i < len; i++)
  1567.     args[i] = SOVEC(new_args)->contents[i];
  1568.     thread->sp = args + len;
  1569.  
  1570.     invoke_methods(HEAD(methods), TAIL(methods), thread, len);
  1571. }
  1572.  
  1573.  
  1574. /* Printer support. */
  1575.  
  1576. static void print_func(obj_t func)
  1577. {
  1578.     obj_t class = FUNC(func)->class;
  1579.     obj_t class_name = obj_ptr(struct class *, class)->debug_name;
  1580.     obj_t debug_name = FUNC(func)->debug_name;
  1581.     char *class_str;
  1582.  
  1583.     if (class_name != NULL && class_name != obj_False)
  1584.     class_str = sym_name(class_name);
  1585.     else
  1586.     class_str = "unknown function";
  1587.  
  1588.     if (debug_name != NULL && debug_name != obj_False) {
  1589.     printf("{%s ", class_str);
  1590.     prin1(debug_name);
  1591.     putchar('}');
  1592.     }
  1593.     else
  1594.     printf("{anonymous %s 0x%08lx}", class_str, (unsigned long)func);
  1595. }
  1596.  
  1597. static void print_method(obj_t method)
  1598. {
  1599.     obj_t class = METHOD(method)->class;
  1600.     obj_t class_name = obj_ptr(struct class *, class)->debug_name;
  1601.     obj_t debug_name = METHOD(method)->debug_name;
  1602.     char *class_str;
  1603.  
  1604.     if (class_name != NULL && class_name != obj_False)
  1605.     class_str = sym_name(class_name);
  1606.     else
  1607.     class_str = "unknown function";
  1608.  
  1609.     if (debug_name != NULL && debug_name != obj_False) {
  1610.     printf("{%s ", class_str);
  1611.     prin1(debug_name);
  1612.     putchar(' ');
  1613.     }
  1614.     else
  1615.     printf("{anonymous %s 0x%08lx ", class_str, (unsigned long)method);
  1616.  
  1617.  
  1618.     prin1(METHOD(method)->specializers);
  1619.     putchar('}');
  1620. }    
  1621.  
  1622.  
  1623. /* GC stuff. */
  1624.  
  1625. static void scav_func(struct function *func)
  1626. {
  1627.     scavenge(&func->debug_name);
  1628.     scavenge(&func->keywords);
  1629.     scavenge(&func->result_types);
  1630.     scavenge(&func->more_results_type);
  1631. }
  1632.  
  1633. static int scav_raw_func(struct object *ptr)
  1634. {
  1635.     scav_func((struct function *)ptr);
  1636.  
  1637.     return sizeof(struct function);
  1638. }
  1639.  
  1640. static obj_t trans_raw_func(obj_t func)
  1641. {
  1642.     return transport(func, sizeof(struct function));
  1643. }
  1644.  
  1645. static int scav_raw_method(struct object *ptr)
  1646. {
  1647.     scav_func((struct function *)ptr);
  1648.     scavenge(&((struct method *)ptr)->specializers);
  1649.     scavenge(&((struct method *)ptr)->class_cache);
  1650.  
  1651.     return sizeof(struct method);
  1652. }
  1653.     
  1654. static obj_t trans_raw_method(obj_t method)
  1655. {
  1656.     return transport(method, sizeof(struct method));
  1657. }
  1658.  
  1659. static int scav_builtin_method(struct object *ptr)
  1660. {
  1661.     scav_func((struct function *)ptr);
  1662.     scavenge(&((struct builtin_method *)ptr)->specializers);
  1663.     scavenge(&((struct builtin_method *)ptr)->class_cache);
  1664.  
  1665.     return sizeof(struct builtin_method);
  1666. }
  1667.     
  1668. static obj_t trans_builtin_method(obj_t method)
  1669. {
  1670.     return transport(method, sizeof(struct builtin_method));
  1671. }
  1672.  
  1673. static int scav_byte_method(struct object *ptr)
  1674. {
  1675.     struct byte_method *method = (struct byte_method *)ptr;
  1676.     int i;
  1677.  
  1678.     scav_func((struct function *)ptr);
  1679.     scavenge(&method->specializers);
  1680.     scavenge(&method->class_cache);
  1681.     scavenge(&method->component);
  1682.  
  1683.     for (i = 0; i < method->n_closure_vars; i++)
  1684.     scavenge(method->lexenv + i);
  1685.  
  1686.     return sizeof(struct byte_method) + sizeof(obj_t)*method->n_closure_vars;
  1687. }
  1688.  
  1689. static obj_t trans_byte_method(obj_t method)
  1690. {
  1691.     int nvars = BYTE_METHOD(method)->n_closure_vars;
  1692.  
  1693.     return transport(method, sizeof(struct byte_method) + sizeof(obj_t)*nvars);
  1694. }
  1695.  
  1696. static int scav_method_info(struct object *ptr)
  1697. {
  1698.     struct method_info *info = (struct method_info *)ptr;
  1699.  
  1700.     scavenge(&info->keys);
  1701.     scavenge(&info->component);
  1702.  
  1703.     return sizeof(struct method_info);
  1704. }
  1705.  
  1706. static obj_t trans_method_info(obj_t info)
  1707. {
  1708.     return transport(info, sizeof(struct method_info));
  1709. }
  1710.  
  1711. static int scav_accessor_method(struct object *ptr)
  1712. {
  1713.     struct accessor_method *method = (struct accessor_method *)ptr;
  1714.  
  1715.     scav_func((struct function *)ptr);
  1716.     scavenge(&method->specializers);
  1717.     scavenge(&method->class_cache);
  1718.     scavenge(&method->datum);
  1719.  
  1720.     return sizeof(struct accessor_method);
  1721. }
  1722.     
  1723. static obj_t trans_accessor_method(obj_t method)
  1724. {
  1725.     return transport(method, sizeof(struct accessor_method));
  1726. }
  1727.  
  1728. static int scav_gf(struct object *ptr)
  1729. {
  1730.     struct gf *gf = (struct gf *)ptr;
  1731.  
  1732.     scav_func((struct function *)gf);
  1733.     scavenge(&gf->methods);
  1734.     scavenge(&gf->cache);
  1735.  
  1736.     return sizeof(struct gf);
  1737. }
  1738.  
  1739. static obj_t trans_gf(obj_t gf)
  1740. {
  1741.     return transport(gf, sizeof(struct gf));
  1742. }
  1743.  
  1744. static int scav_gf_cache(struct object *ptr)
  1745. {
  1746.     struct gf_cache *gf_cache = (struct gf_cache *)ptr;
  1747.     int i, max = gf_cache->size;
  1748.  
  1749.     scavenge(&gf_cache->cached_result);
  1750.     for (i = 0; i < max; i++)
  1751.     scavenge(&gf_cache->cached_classes[i]);
  1752.  
  1753.     return sizeof(struct gf_cache) + max * sizeof(obj_t);
  1754. }
  1755.  
  1756. static obj_t trans_gf_cache(obj_t gf_cache)
  1757. {
  1758.     return transport(gf_cache, (sizeof(struct gf_cache) +
  1759.                 obj_ptr(struct gf_cache *, gf_cache)->size
  1760.                 * sizeof(obj_t)));
  1761. }
  1762.  
  1763. void scavenge_func_roots(void)
  1764. {
  1765.     scavenge(&obj_FunctionClass);
  1766.     scavenge(&obj_RawFunctionClass);
  1767.     scavenge(&obj_MethodClass);
  1768.     scavenge(&obj_RawMethodClass);
  1769.     scavenge(&obj_BuiltinMethodClass);
  1770.     scavenge(&obj_ByteMethodClass);
  1771.     scavenge(&obj_AccessorMethodClass);
  1772.     scavenge(&obj_MethodInfoClass);
  1773.     scavenge(&obj_GFClass);
  1774.     scavenge(&obj_GFCacheClass);
  1775. }
  1776.  
  1777.  
  1778. /* Init stuff. */
  1779.  
  1780. void make_func_classes(void)
  1781. {
  1782.     obj_FunctionClass = make_abstract_class(TRUE);
  1783.     obj_RawFunctionClass = make_builtin_class(scav_raw_func, trans_raw_func);
  1784.     obj_MethodClass = make_abstract_class(TRUE);
  1785.     obj_RawMethodClass
  1786.     = make_builtin_class(scav_raw_method, trans_raw_method);
  1787.     obj_BuiltinMethodClass
  1788.     = make_builtin_class(scav_builtin_method, trans_builtin_method);
  1789.     obj_ByteMethodClass
  1790.     = make_builtin_class(scav_byte_method, trans_byte_method);
  1791.     obj_AccessorMethodClass
  1792.     = make_builtin_class(scav_accessor_method, trans_accessor_method);
  1793.     obj_MethodInfoClass
  1794.     = make_builtin_class(scav_method_info, trans_method_info);
  1795.     obj_GFClass = make_builtin_class(scav_gf, trans_gf);
  1796.     obj_GFCacheClass = make_builtin_class(scav_gf_cache, trans_gf_cache);
  1797. }
  1798.  
  1799. void init_func_classes(void)
  1800. {
  1801.     init_builtin_class(obj_FunctionClass, "<function>", obj_ObjectClass, NULL);
  1802.     def_printer(obj_FunctionClass, print_func);
  1803.     init_builtin_class(obj_RawFunctionClass, "<builtin-function>",
  1804.                obj_FunctionClass, NULL);
  1805.     init_builtin_class(obj_MethodClass, "<method>", obj_FunctionClass, NULL);
  1806.     def_printer(obj_MethodClass, print_method);
  1807.     init_builtin_class(obj_RawMethodClass, "<raw-method>",
  1808.                obj_MethodClass, NULL);
  1809.     init_builtin_class(obj_BuiltinMethodClass, "<builtin-method>",
  1810.                obj_MethodClass, NULL);
  1811.     init_builtin_class(obj_ByteMethodClass, "<byte-method>",
  1812.                obj_MethodClass, NULL);
  1813.     init_builtin_class(obj_MethodInfoClass, "<method-info>",
  1814.                obj_ObjectClass, NULL);
  1815.     init_builtin_class(obj_AccessorMethodClass, "<slot-accessor-method>",
  1816.                obj_MethodClass, NULL);
  1817.     init_builtin_class(obj_GFClass, "<generic-function>",
  1818.                obj_FunctionClass, NULL);
  1819.     init_builtin_class(obj_GFCacheClass, "<generic-function-cache>",
  1820.                obj_ObjectClass, NULL);
  1821. }
  1822.  
  1823. void init_func_functions(void)
  1824. {
  1825.     define_function("make-generic-function",
  1826.             listn(7, obj_ObjectClass, obj_IntegerClass,
  1827.               obj_ObjectClass,
  1828.               type_union(object_class(obj_False), obj_ListClass),
  1829.               obj_ObjectClass, obj_ListClass,
  1830.               type_union(object_class(obj_False), obj_TypeClass)),
  1831.             FALSE, obj_False, FALSE,
  1832.             list1(obj_GFClass), dylan_make_gf);
  1833.     define_generic_function("add-method", 2, FALSE, obj_False, FALSE,
  1834.                 list2(obj_MethodClass,obj_ObjectClass), obj_False);
  1835.     add_method(find_variable(module_BuiltinStuff, symbol("add-method"),
  1836.                  FALSE, FALSE)->value,
  1837.            make_raw_method("add-method",list2(obj_GFClass,obj_MethodClass),
  1838.                    FALSE, obj_False, FALSE,
  1839.                    list2(obj_MethodClass, obj_ObjectClass),
  1840.                    obj_False, dylan_add_method));
  1841.     define_method("generic-function-methods", list1(obj_GFClass), FALSE,
  1842.           obj_False, FALSE, obj_ObjectClass, generic_function_methods);
  1843.     define_method("generic-function-mandatory-keywords", list1(obj_GFClass),
  1844.           FALSE, obj_False, FALSE, obj_ObjectClass,
  1845.           generic_function_keywords);
  1846.     define_method("method-specializers", list1(obj_MethodClass), FALSE,
  1847.           obj_False, FALSE, obj_ObjectClass, method_specializers);
  1848.     define_generic_function("function-arguments", 1, FALSE, obj_False, FALSE,
  1849.                 list3(obj_IntegerClass, obj_BooleanClass,
  1850.                   obj_ObjectClass),
  1851.                 obj_False);
  1852.     add_method(find_variable(module_BuiltinStuff, symbol("function-arguments"),
  1853.                  FALSE, FALSE)->value,
  1854.            make_raw_method("function-arguments", list1(obj_FunctionClass),
  1855.                    FALSE, obj_False, FALSE,
  1856.                    list3(obj_IntegerClass, obj_BooleanClass,
  1857.                      obj_ObjectClass),
  1858.                    obj_False, dylan_function_arguments));
  1859.     add_method(find_variable(module_BuiltinStuff, symbol("function-arguments"),
  1860.                  FALSE, FALSE)->value,
  1861.            make_raw_method("function-arguments", list1(obj_MethodClass),
  1862.                    FALSE, obj_False, FALSE,
  1863.                    list3(obj_IntegerClass, obj_BooleanClass,
  1864.                      obj_ObjectClass),
  1865.                    obj_False, dylan_method_arguments));
  1866.     define_method("sorted-applicable-methods", list1(obj_GFClass), TRUE,
  1867.           obj_False, FALSE, obj_ObjectClass, dylan_sorted_app_meths);
  1868.     define_method("applicable-method?", list1(obj_MethodClass), TRUE,
  1869.           obj_False, FALSE, obj_BooleanClass, dylan_app_meth_p);
  1870.     define_method("find-method", list2(obj_GFClass, obj_ListClass), FALSE,
  1871.           obj_False, FALSE, obj_ObjectClass, dylan_find_method);
  1872.     define_method("remove-method", list2(obj_GFClass, obj_MethodClass), FALSE,
  1873.           obj_False, FALSE, obj_ObjectClass, dylan_remove_method);
  1874.     define_constant("do-next-method",
  1875.             make_raw_method("do-next-method",
  1876.                     list2(obj_ObjectClass, obj_ObjectClass),
  1877.                     FALSE, obj_False, FALSE, obj_Nil,
  1878.                     obj_ObjectClass, dylan_do_next_method));
  1879. }
  1880.